;;;-*-SCHEME-*-

;;;;  Top level variable so debugger is always available (even if loaded
;;;  during error)

(eval 

'(define debugger-package
  (make-environment


(define-export exit system-global-environment nil)


;;;Read-execute-print loop for a set of commands associated with functions

(define (letter-commands commands prompt)

  (define (inner-loop val)
    (if (eq? val *noprint*) nil
	(print val))
    (newline)
    (let ((input (readch prompt)))
      (let ((func (or (assq input commands)
		      (assq (char (- (ascii input) 32.)) commands))))
	(if (null? func)
	    (inner-loop *noprint*)
	    (inner-loop ((cdr func)))))))

  (define (driver-loop)
    (catch exit
	   (let ((abort-message
		  (catch again
			 (fluid-let ((abort-to-previous-driver
				      abort-to-nearest-driver)
				     (return-to-caller-of-driver exit)
				     (abort-to-nearest-driver again))
				    (inner-loop *noprint*)))))
	     (display abort-message " Returning to lazy" "loop.")
	     (driver-loop))))
  (driver-loop))

;;;;Environment manipulation package

(define env-package
  (make-environment
   
   (define env nil)
   (define current-frame nil)

   
   ;;; Lexpr since it can take one or no arguments
   
   (define-export (where . possible-env) system-global-environment
     (loop (if (null? possible-env)
	       (the-read-eval-print-environment)
	       (car possible-env))))
   

   (define (loop environment)
     (newline)
     (set! env environment)
     (set! current-frame environment)
     (letter-commands env-commands "Where--> "))


   (define (enter-environment env)
     (read-eval-print env
		      "You are now in the desired environment"
		      "Eval-in-env--> "))
        
   
   (define (show)
     (show-frame current-frame))
   
   (define (show-all)
     (define (s1 env)
       (if (eq? system-global-environment env) *noprint*
	   (sequence
	    (show-frame env)
	    (s1 (frame-parent env)))))
     (s1 env))

   (define (show-frame frame)
     (if (eq? system-global-environment frame)
	 (display "This frame is the global environment")
	 (print (frame-bindings frame)))
     (newline))


  (define (parent)
    (if (eq? system-global-environment parent)
	(display
	 "The current frame is the global environment, it has no parent")
	(sequence
	 (set! current-frame (frame-parent current-frame))
	 (show))))

  (define (son)
    (define (son-1 prev next)
      (if (eq? next current-frame)
	  (set! current-frame prev)
	  (son-1 next (frame-parent next))))
    (if (eq? current-frame env)
	(display "This frame has no offspring")
	(son-1 env (frame-parent env)))
    (show))

  (define (enter) (enter-environment current-frame))
  
  (define (help)
    (display
"
E    Create a read-eval-print loop in the current environment
S    Find the son of the current environment in the current chain
P    Find the parent frame of the current one
H    Display the bindings in the current frame
A    Display the bindings of all the frames in the current chain
Q    Exit
?    Help, print this cruft"))


  (define (exit)
    (return-to-caller-of-driver *noprint*))

  (define env-commands
    (list `(E ,@enter)
	  `(S ,@son)
	  `(P ,@parent)
          `(H ,@show)
	  `(A ,@show-all)
	  `(Q ,@exit)
	  `(? ,@help)))))
  

;;;;History part of the debugger


(define history-package
  (make-environment

   ;;; "State" variables

   (define history nil)
   (define caller nil)
   (define error-info nil)


   (define spine-levels 0)
   (define rib-levels 0)

   (define current-height 0)
   (define current-width 0)

   (define current-reductions nil)
   (define current-branches nil)
   (define current-reduction nil)
   (define $ nil)

   (define toggle nil)
   (define *exit* '(*exit*))
   (define *change-mode* '(*change-mode*))

   ;;; Manipulators:


   (define (rib-reductions rib) (car rib))

   (define (rib-subexpressions rib) (cadr rib))

   
   (define (branch-expression branch) (car branch))

   (define (branch-value branch) (cadr branch))


   (define (reduction-procedure reduction)
     (frame-procedure (cadr reduction)))

   (define (reduction-arguments reduction)
     (frame-arguments (cadr reduction)))

   (define (reduction-environment reduction)
     (cadr reduction))

   (define (reduction-expression reduction)
     (car reduction))

   
   ;;;;Initialization and loops for both modes

   (define-export (debug . flag) system-global-environment
     (set! history (the-saved-history))
     (set! caller return-to-caller-of-driver)
     (if history
	 (sequence
	  (set! error-info
		(let ((original (car the-read-eval-print-messages)))
		  (cons "Message:"
			(if (symbol? original)
			    (list original)
			    original))))
	  (set! spine-levels (-1+ (length history)))
	  (move 0 0 "There is no history saved at all!" nil)
	  (if (memq (reduction-procedure current-reduction)
		    (list error bkpt))
	      (sequence
	       (set!-car current-reductions (cadr current-reductions))
	       (set!-cdr current-reductions (cddr current-reductions))
	       (set!-car (cdar history) '(foo))
	       (move 0 0 "There is no history saved at all!" nil)))
	  (if (and flag (car flag)) (reduction) (all-history))
	  (mode))
	 (display "There is no history saved at all!")))


   (define (lazy-mode)
     (let ((val (letter-commands hist-commands
				 "Lazy-debug--> ")))
       (if (eq? val *exit*)
	   *noprint*
	   (sequence (set! mode normal-mode)
		     (normal-mode)))))

   
   (define (normal-mode)
     (fluid-let ((exit return-to-caller-of-driver))
	(catch toggle-mode
	       (sequence
		(set! toggle toggle-mode)
		(read-eval-print history-package
				 "You are in debugger command mode"
				 "Debugger-command--> "))))
     (set! mode lazy-mode)
     (lazy-mode))

     
   ;;;; Commands

   ;;;Environments:
   
   (define (debug-where)                        ;command W
     (where
      (reduction-environment current-reduction)))

   (define (enter)                              ;command E
     ((access enter-environment env-package)
      (reduction-environment current-reduction)))

   (define (eval-in-current-environment)        ;command V
     (newline)
     (eval (read "Eval--> ")
	   (reduction-environment current-reduction)))

   (define (procedure)
     (reduction-procedure current-reduction))

   (define (environment)
     (reduction-environment current-reduction))

   
   ;;;Proceeding:
   
   (define (return-lazy)                        ;command R
     (newline)
     (let ((inp (read "Exp to proceed with: -> ")))
       (newline)
       (if (read "Confirm: [T or NIL] -> ")
	   (return (if (eq? inp '$) $ inp))
	   *noprint*)))


;;; FIX DYNAMIC THROW TO FORCE VALUE OF DELAYS WHICH GO THROUGH IT.

   (define (return exp)
     (let ((val (eval exp	;EVALUATION SHOULD HAPPEN AFTER THROW!
		      (reduction-environment current-reduction)))
	   (appropriate-caller (find-caller current-height caller)))
       (merge-history current-height)
       (appropriate-caller val)))

   (define find-caller (get-lisp-procedure 'find-caller))

   ;;;Displaying:

   (define (all-history)                        ;command H
     (display-history history 0))

   (define (display-history left level)
     (cond ((null? left) *noprint*)
	   ((eq? left 'wrap-around)
	    (display "Wrap around in history!")
	    (newline))
	   (else
	    (display-rib (rib-reductions (car left)) 0 level)
	    (display-history (cdr left) (1+ level)))))


   (define (all-reductions)                     ;command A
     (display-rib current-reductions 0 current-height))

   (define (display-rib rib wi he)
     (cond ((null? rib) *noprint*)
	   ((eq? rib 'wrap-around)
	    (display "Wrap around in the reductions at this level!")
	    (newline))
	   ((and (= he spine-levels)
		 (eq? (reduction-procedure (car rib))
		      eval))
	    *noprint*)
	   (else
	    (display-reduction (car rib) he wi)
	    (display-rib (cdr rib) (1+ wi) he))))

   
   (define (reduction)                          ;command S
     (newline)
     (display-reduction current-reduction current-height current-width))
   
   (define (display-reduction reduction he wi)
     (fluid-let ((*print-depth* 5)
		 (*print-breadth* 5))
       (display "Subproblem level:" he " Reduction number:" wi)
       (display "Expression" (unsyntax (reduction-expression reduction)))
       (display "Within procedure" (reduction-procedure reduction)
		"applied to" (reduction-arguments reduction))
       (newline)))


   (define (subexpressions)                     ;command X
     (display-branches current-branches))
   
   (define (display-branches branches)
     (cond ((null? branches) *noprint*)
	   ((eq? branches 'wrap-around)
	    (display "Wrap around in the subexpressions at this level!")
	    (newline))
	   (else
	    (fluid-let ((*print-depth* 5)
			(*print-breadth* 5))
	      (display "Subexpression:"
		       (unsyntax (branch-expression (car branches)))
		       " value:" (branch-value (car branches)))
	      (newline))
	    (display-branches (cdr branches)))))



   (define (print-procedure)                    ;command P
     (pp (reduction-procedure current-reduction)))



   ;;;Motion:
   
   (define (previous-subproblem)                ;command D
     (move (1+ current-height) 0
	   "You are already at the first subproblem level"
	   t))
   
   (define (next-subproblem)                    ;command U
     (move (-1+ current-height) 0
	   "You are already at the last subproblem level"
	   t))
   
   (define (next-reduction)                     ;command F
     (h-move (-1+ current-width)
	     "You are already at the last reduction at this level"
	     t))

   (define (previous-reduction)                 ;command B
     (h-move (1+ current-width)
	     "You are already at the first reduction at this level"
	     t))

   (define (go-lazy)                            ;command G
     (newline)
     (select-subproblem-loop)
     (select-reduction-loop)
     (reduction))

   (define (select-subproblem-loop)
     (princ "Subproblem level (0 to ")
     (princ spine-levels)
     (cond ((null? (select-subproblem (read ") --> ")))
	    (display "That subproblem doesn't exist")
	    (select-subproblem-loop))
	   (else
	    *noprint*)))

   (define (select-subproblem height)
     (and (integer? height)
	  (not (< height 0))
	  (not (> height spine-levels))
	  (let ((temp-rib (nth height history)))
	    (set! current-reductions (rib-reductions temp-rib))
	    ;; Current branch doesn't have value
	    (set! current-branches (cdr (rib-subexpressions temp-rib)))
	    (set! current-height height)
	    (select-reduction 0)
	    height)))

   (define (select-reduction-loop)
     (princ "Reduction number (0 to ")
     (princ (- (length current-reductions) 1))
     (cond ((null? (select-reduction (read ") --> ")))
	    (display "That reduction doesn't exist")
	    (select-reduction-loop))
	   (else
	    *noprint*)))

   (define (select-reduction width)
     (and (integer? width)
	  (not (< width 0))
	  (< width current-reductions)
	  (sequence
	   (set! current-width width)
	   (set! current-reduction (nth current-width current-reductions))
	   (set! $ (unsyntax (reduction-expression current-reduction)))
	   width)))

   (define (go level reduction)
     (move level reduction "That reduction doesn't exist" t))

   (define (move he wi error-message display?)
     (cond ((null? (select-subproblem he))
	    (display error-message))
	   (else
	    (h-move wi error-message display?)
	    (if (= wi current-width) *noprint*
		(h-move 0 "Bad history" nil)))))

   (define (h-move wi error-message display?)
     (cond ((null? (select-reduction wi))
	    (display error-message))
	   ((null? display?)
	    *noprint*)
	   (else
	    (reduction))))
   
   ;;; Debugger system commands

   (define (info)                              ;command I
     (newline)
     (apply display error-info)
     (newline))

   (define (help)                              ;command ?
     (display help-message))

   (define (change-mode)                       ;command M
     (return-to-caller-of-driver *change-mode*))

   (define (exit-lazy)                         ;command Q
     (return-to-caller-of-driver *exit*))


   (define hist-commands
     (list (cons '? help)
	   (cons 'H all-history)
	   (cons 'A all-reductions)
           (cons 'Q exit-lazy)
	   (cons 'U next-subproblem)
	   (cons 'D previous-subproblem)
	   (cons 'F next-reduction)
	   (cons 'B previous-reduction)
	   (cons 'X subexpressions)
	   (cons 'I info)
	   (cons 'V eval-in-current-environment)
	   (cons 'E enter)
	   (cons 'S reduction)
	   (cons 'W debug-where)
	   (cons 'R return-lazy)
	   (cons 'M change-mode)
	   (cons 'G go-lazy)
	   (cons 'P print-procedure)))


   (define help-message "
U     Move up one subproblem level to <Next-subproblem>
D     Move down one subproblem level to <Previous-subproblem>
F     Move forward to <Next-reduction> on the same subproblem level
B     Move backwards to <Previous-reduction> on the same subproblem level
G     <Go> to subproblem and reduction desired

S     Show the current <Reduction> in short form
X     Show the <Subexpressions> of the last reduction at this level
P     <Print-procedure>, pretty-prints current procedure
A     <All-reductions>, display all the reductions at this level
H     <All-history>, display all the available history

V     <Eval-in-current-environment> an expression
E     <Enter>, enter a read-eval-print loop in the current environment
R     <Return>, evaluate an expression and proceed with it
W     <Debug-where>, display and manipulate the current environment

I     <Info>, repeat error message
M     <Toggle>, change debug mode
Q     <Exit> the debugger
?     <Help> prints this garbage")

   (define mode lazy-mode)))
))


scheme-system-package)